{*******************************************************************************
* The contents of this file are used with permission, subject to the Mozilla   *
* Public License Version 1.1 (the "License"); you may not use this file except *
* in compliance with the License. You may obtain a copy of the License at      *
* http://www.mozilla.org/MPL/                                                  *
*                                                                              *
* Software distributed under the License is distributed on an "AS IS" basis,   *
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for *
* the specific language governing rights and limitations under the License.    *
*                                                                              *
* The Original Code is distributed as part of the "mediate" product and is     *
* Copyright (C) @home media limited. All Rights Reserved.                      *
*                                                                              *
* Email: support@athomemedia.co.uk                                             *
* Web:   http://www.athomemedia.co.uk                                          *
*******************************************************************************}

unit VideoTags;

interface

uses DirectShow9;

const
  THUMB_SEEK_TIME = 40; // Seek position for taking thumbnail snapshot

type
  TAHMVideoFile = class(TObject)
  private
    FMedia: IMediaDet;
    FFileName: WideString;
    FDuration: LongWord;
    FBitrate: LongWord;
    FImageURL: WideString;
    FThumbPath: WideString;
    FCreateThumb: Boolean;
    FInitialized: Boolean;
    FFailed: Boolean;
    function GetThumbnailURL: WideString;
  protected
    property ThumbnailURL: WideString read GetThumbnailURL;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    function OpenFile(FileName: WideString): Boolean;
    function ReadTags: Boolean;
    procedure Close;
    property ThumbnailPath: WideString read FThumbPath write FThumbPath;
    property CreateThumbnails: Boolean read FCreateThumb write FCreateThumb;
    property Duration: LongWord read FDuration;
    property Bitrate: LongWord read FBitrate;
    property ImageURL: WideString read FImageURL;
  end;

implementation

uses ActiveX, UniCode, TagUtils;

// TAHMVideoFile

constructor TAHMVideoFile.Create;
begin
  inherited;

  Clear;
end;

destructor TAHMVideoFile.Destroy;
begin
  FMedia := nil;

  // Release COM library from this thread
  if FInitialized then CoUninitialize;

  inherited;
end;

function TAHMVideoFile.GetThumbnailURL: WideString;
begin
  FImageURL := FThumbPath + GetThumbnailName(FFileName);
  Result := FImageURL;
end;

procedure TAHMVideoFile.Clear;
begin
  FDuration := 0;
  FBitrate := 0;
  FImageURL := '';
end;

function TAHMVideoFile.OpenFile(FileName: WideString): Boolean;
var
  hr: HRESULT;
begin
  // Set filename property & clear media tags
  FFileName := FileName;
  Clear;

  // Since the media detector is extremely slow we make a small optimisation
  // here by checking for an existing thumbnail in the cache. If one is found
  // we return that rather than parsing the media file for bitrate and duration.
  // Those properties will thus be zero, but they are not presently used within
  // mediate - we're mainly interested in the thumbnail
  if FCreateThumb and FileExistsW(ThumbnailURL) then
  begin
    // Clear filename to skip parsing later
    FFileName := '';
    Result := True;
    Exit;
  end
  else
  begin
    // Clear thumbnail URL until it's created later
    FImageURL := '';
  end;

  try
    // Create and cache media detector
    if not FFailed then
    begin
      // Initialise COM library for this thread context
      if not FInitialized then
      begin
        CoInitialize(nil);
        FInitialized := True;
      end;

      hr := CoCreateInstance(CLSID_MediaDet, nil, CLSCTX_INPROC, IMediaDet, FMedia);
      if hr <> S_OK then
      begin
        // Failed to create media detector
        FMedia := nil;
        FFailed := True;
      end
      else
        FFailed := False;
    end;

    // Attempt to open video file
    if FMedia <> nil then
    begin
      hr := FMedia.put_Filename(FFilename);
      Result := (hr = S_OK);
    end
    else
      Result := False;
  except
    Result := False;
  end;
end;

function TAHMVideoFile.ReadTags: Boolean;
var
  Target: WideString;
  VideoStreams: Integer;
  Stream: Integer;
  StreamType: TGUID;
  MediaType: TAMMediaType;
  Header: PVideoInfoHeader;
  Width, Height: Integer;
  Value: Double;
  hr: HRESULT;
begin
  // If filename is blank then we're simply returning a previous cached
  // image thumbnail, and not parsing bitrate or duration properties.
  if FFileName = '' then
  begin
    // Simulate succesful parsing
    Result := True;
    Exit;
  end;

  // Set default result - failed
  Result := False;
  try
    // Sanity check we have a media detector for use
    if FMedia = nil then Exit;

    // Search for video stream type
    hr := FMedia.get_OutputStreams(VideoStreams);
    if (hr = S_OK) and (VideoStreams > 0) then
    begin
      for Stream := 0 to Pred(VideoStreams) do
      begin
        hr := FMedia.put_CurrentStream(Stream);
        if hr <> S_OK then Exit;

        hr := FMedia.get_StreamType(StreamType);
        if (hr = S_OK) and IsEqualGUID(StreamType, KSDATAFORMAT_TYPE_VIDEO) then
        begin
          // Found matching video stream - query details
          hr := FMedia.get_StreamLength(Value);
          if hr = S_OK then FDuration := Round(Value);

          hr := FMedia.get_FrameRate(Value);
          if hr = S_OK then FBitRate := Round(Value);

          // Do we want to create video thumbnails?
          if CreateThumbnails then
          begin
            // Get media type details
            hr := FMedia.get_StreamMediaType(MediaType);
            if hr <> S_OK then Exit;

            // Check for video header
            if IsEqualGUID(MediaType.formattype, FORMAT_VideoInfo) and
               (MediaType.cbFormat >= SizeOf(TVideoInfoHeader)) then
            begin
              // Get media dimensions from video header
              Header := PVideoInfoHeader(MediaType.pbFormat);
              Width := Header.bmiHeader.biWidth;
              Height := Header.bmiHeader.biHeight;

              // Compensate for upside down video
              if Height < 0 then Height := -Height;

              // Ensure dimensions are both divisible by 4
              Height := (Height div 4) * 4;
              Width := (Width div 4) * 4;

              // Validate video dimensions
              if (Width > 0) and (Height > 0) then
              begin
                // Generate target URL for thumbnail
                Target := ThumbnailURL;

                // No point saving if thumbnail already exists
                if not FileExistsW(Target) then
                begin
                  FMedia.WriteBitmapBits(THUMB_SEEK_TIME, Width, Height, Target);
                end;
              end;
            end;

            // Free format block allocated by above call
            if MediaType.cbFormat <> 0 then
            begin
              CoTaskMemFree(MediaType.pbFormat);
              MediaType.pbFormat := nil;
            end;
          end;

          // No need to check other streams
          Break;
        end;
      end;

      // Success
      Result := True;
    end;
  except
    // Media detector error - parsing failed
  end;
end;

procedure TAHMVideoFile.Close;
begin
  // Release media detector instance
  FMedia := nil;
end;


end.
